home *** CD-ROM | disk | FTP | other *** search
/ CD Concept 6 / CD Concept 06.iso / mac / UTILITAIRE / Little Smalltalk v3.1.4 / C Source / Sources / primitive.c < prev    next >
Text File  |  1995-01-26  |  17KB  |  700 lines
  1. /*
  2.     Little Smalltalk, version 3
  3.     Written by Tim Budd, Oregon State University, July 1988
  4.  
  5.     Primitive processor
  6.  
  7.     primitives are how actions are ultimately executed in the Smalltalk 
  8.     system.
  9.     unlike ST-80, Little Smalltalk primitives cannot fail (although
  10.     they can return nil, and methods can take this as an indication
  11.     of failure).  In this respect primitives in Little Smalltalk are
  12.     much more like traditional system calls.
  13.  
  14.     Primitives are combined into groups of 10 according to 
  15.     argument count and type, and in some cases type checking is performed.
  16.  
  17.     IMPORTANT NOTE:
  18.         The technique used to tell if an arithmetic operation
  19.         has overflowed in intBinary() depends upon integers
  20.         being 16 bits.  If this is not true, other techniques
  21.         may be required.
  22.     
  23.     system specific I/O primitives are found in a different file.
  24.     
  25.     Primitive 20 added by Julian Barkway, Nov. 1994, to support the 'become:'
  26.     method in class Object.
  27. */
  28.  
  29. # include <stdio.h>
  30. # include <stdlib.h>
  31. # include <time.h>
  32. # include <math.h>
  33. # include "env.h"
  34. # include "memory.h"
  35. # include "names.h"
  36. # include <string.h>
  37. # ifdef STRING
  38. # include <string.h>
  39. # endif
  40. # ifdef STRINGS
  41. # include <strings.h>
  42. # endif
  43.  
  44. # ifdef SIGNAL
  45. # include <signal.h>
  46. # include <setjmp.h>
  47. # endif
  48. # ifdef CTRLBRK
  49. # include <dos.h>
  50. # include <signal.h>
  51. # include <setjmp.h>
  52. # endif
  53.  
  54. #ifdef THINKC
  55. #include "primitive.proto.h"
  56. # ifdef TCL
  57. #   include "tclprim.proto.h"
  58. # else
  59. #   include "winprim.proto.h"
  60. # endif
  61. #include "names.proto.h"
  62. #include "news.proto.h"
  63. #include "interp.proto.h"
  64. #include "parser.proto.h"
  65. #include "memory.proto.h"
  66. #else
  67. # ifdef SIGNAL
  68. static object zeroaryPrims(int number);
  69. static int unaryPrims(int number, object firstarg);
  70. static int binaryPrims(int number, object firstarg, object secondarg);
  71. static int trinaryPrims(int number, object firstarg, object secondarg, object thirdarg);
  72. static int intUnary(int number, int firstarg);
  73. static object intBinary(int number, int firstarg, int secondarg);
  74. static int strUnary(int number, char *firstargument);
  75. static int floatUnary(int number, double firstarg);
  76. static object floatBinary(int number, double first, double second);
  77.  
  78. static object zeroaryPrims(int);
  79. static int unaryPrims(int, object);
  80. static int binaryPrims(int, object, object);
  81. static int trinaryPrims(int, object, object, object);
  82. static int intUnary(int, int);
  83. static object intBinary(int, int, int);
  84. static int strUnary(int, char *);
  85. static int floatUnary(int, double);
  86. static object floatBinary(int, double, double);
  87. static object zeroaryPrims(int);
  88. static int unaryPrims(int, object);
  89. static int binaryPrims(int, object, object);
  90. static int trinaryPrims(int, object, object, object);
  91. static int intUnary(int, int);
  92. static object intBinary(int, int, int);
  93. static int strUnary(int, char *);
  94. static int floatUnary(int, double);
  95. static object floatBinary(int, double, double);
  96. # endif
  97.  
  98. extern long time();
  99.  
  100. #endif
  101.  
  102. extern object processStack;
  103. extern int linkPointer;
  104. extern double frexp(), ldexp();
  105. extern object ioPrimitive(INT X OBJP);
  106. extern object sysPrimitive(INT X OBJP);
  107.  
  108. # ifdef SIGNAL
  109. static jmp_buf jb;
  110. brkfun(void) { longjmp(jb, 1); }
  111. brkignore(void) {;}
  112. # endif
  113. # ifdef CTRLBRK
  114. static jmp_buf jb;
  115. brkfun(void) { longjmp(jb, 1); }
  116. brkignore(void) {;}
  117. # endif
  118.  
  119. static object zeroaryPrims(int number)
  120. {    short i;
  121.     object returnedObject;
  122.     int objectCount();
  123.  
  124.     returnedObject = nilobj;
  125.     switch(number) {
  126.  
  127.         case 1:
  128.             fprintf(stderr,"did primitive 1\n");
  129.             break;
  130.  
  131.         case 2:
  132.             fprintf(stderr,"object count %d\n", objectCount());
  133.             break;
  134.  
  135.         case 3:            /* return a random number */
  136.             /* this is hacked because of the representation */
  137.             /* of integers as shorts */
  138.             i = rand() >> 8;    /* strip off lower bits */
  139.             if (i < 0) i = - i;
  140.             returnedObject = newInteger(i>>1);
  141.             break;
  142.  
  143.         case 4:        /* return time in seconds */
  144.             i = (short) time(NULL);
  145.             returnedObject = newInteger(i);
  146.             break;
  147.  
  148.         case 5:        /* flip watch - done in interp */
  149.             break;
  150.  
  151.         case 9:
  152.             exit(0);
  153.  
  154.         default:        /* unknown primitive */
  155.             sysError("unknown primitive","zeroargPrims");
  156.             break;
  157.     }
  158.     return(returnedObject);
  159. }
  160.  
  161. static int unaryPrims(int number, object firstarg)
  162. {    int i, j, saveLinkPointer;
  163.     object returnedObject, saveProcessStack;
  164.  
  165.     returnedObject = firstarg;
  166.     switch(number) {
  167.         case 1:        /* class of object */
  168.             returnedObject = getClass(firstarg);
  169.             break;
  170.  
  171.         case 2:        /* basic size of object */
  172.             if (isInteger(firstarg))
  173.                 i = 0;
  174.             else {
  175.                 i = sizeField(firstarg);
  176.                 /* byte objects have negative size */
  177.                 if (i < 0) i = (-i);
  178.                 }
  179.             returnedObject = newInteger(i);
  180.             break;
  181.  
  182.         case 3:        /* hash value of object */
  183.             if (isInteger(firstarg))
  184.                 returnedObject = firstarg;
  185.             else
  186.                 returnedObject = newInteger(firstarg);
  187.             break;
  188.  
  189.         case 4:        /* debugging print */
  190.             fprintf(stderr,"primitive 14 %d\n", firstarg);
  191.             break;
  192.         
  193.         case 8:        /* change return point - block return */
  194.             /* first get previous link pointer */
  195.             i = intValue(basicAt(processStack, linkPointer));
  196.             /* then creating context pointer */
  197.             j = intValue(basicAt(firstarg, 1));
  198.             if (basicAt(processStack, j+1) != firstarg) {
  199.                 returnedObject = falseobj;
  200.                 break;
  201.                 }
  202.             /* first change link pointer to that of creator */
  203.             fieldAtPut(processStack, i, 
  204.                 basicAt(processStack, j));
  205.             /* then change return point to that of creator */
  206.             fieldAtPut(processStack, i+2, 
  207.                 basicAt(processStack, j+2));
  208.             returnedObject = trueobj;
  209.             break;
  210.  
  211.         case 9:            /* process execute */
  212.             /* first save the values we are about to clobber */
  213.             saveProcessStack = processStack;
  214.             saveLinkPointer = linkPointer;
  215. # ifdef SIGNAL
  216.             /* trap control-C */
  217.             signal(SIGINT, brkfun);
  218.             if (setjmp(jb)) {
  219.                 returnedObject = falseobj;
  220.                 }
  221.             else
  222. # endif
  223. # ifdef CRTLBRK
  224.             /* trap control-C using dos ctrlbrk routine */
  225.             ctrlbrk(brkfun);
  226.             if (setjmp(jb)) {
  227.                 returnedObject = falseobj;
  228.                 }
  229.             else
  230. # endif
  231.             if (execute(firstarg, 5000))
  232.                 returnedObject = trueobj;
  233.             else
  234.                 returnedObject = falseobj;
  235.             /* then restore previous environment */
  236.             processStack = saveProcessStack;
  237.             linkPointer = saveLinkPointer;
  238. # ifdef SIGNAL
  239.             signal(SIGINT, brkignore);
  240. # endif
  241. # ifdef CTRLBRK
  242.             ctrlbrk(brkignore);
  243. # endif
  244.             break;
  245.  
  246.         default:        /* unknown primitive */
  247.             sysError("unknown primitive","unaryPrims");
  248.             break;
  249.     }
  250.     return(returnedObject);
  251. }
  252.  
  253. static int binaryPrims(int number, object firstarg, object secondarg)
  254. {    char buffer[2000];
  255.     int i;
  256.     object returnedObject;
  257.  
  258.     returnedObject = firstarg;
  259.     switch(number) {
  260.  
  261. /* Following primitive added by Julian Barkway */
  262.         case 0:        /* make firstarg 'become' secondarg and vice-versa */
  263.             swapObjects (firstarg, secondarg);
  264.             returnedObject = firstarg;
  265.             break;
  266.  
  267.         case 1:        /* object identity test */
  268.             if (firstarg == secondarg)
  269.                 returnedObject = trueobj;
  270.             else
  271.                 returnedObject = falseobj;
  272.             break;
  273.  
  274.         case 2:        /* set class of object */
  275.             decr(classField(firstarg));
  276.             setClass(firstarg, secondarg);
  277.             returnedObject = firstarg;
  278.             break;
  279.  
  280.         case 3:        /* debugging stuff */
  281.             fprintf(stderr,"primitive 23 %d %d\n", firstarg, secondarg);
  282.             break;
  283.  
  284.         case 4:        /* string cat */
  285.             ignore strcpy(buffer, charPtr(firstarg));
  286.             ignore strcat(buffer, charPtr(secondarg));
  287.             returnedObject = newStString(buffer);
  288.             break;
  289.         
  290.         case 5:        /* basicAt: */
  291.             if (! isInteger(secondarg))
  292.                 sysError("non integer index","basicAt:");
  293.             returnedObject = basicAt(firstarg, intValue(secondarg));
  294.             break;
  295.  
  296.         case 6:        /* byteAt: */
  297.             if (! isInteger(secondarg))
  298.                 sysError("non integer index","byteAt:");
  299.             i = byteAt(firstarg, intValue(secondarg));
  300.             if (i < 0) i += 256;
  301.             returnedObject = newInteger(i);
  302.             break;
  303.  
  304.         case 7:        /* symbol set */
  305.             nameTableInsert(symbols, strHash(charPtr(firstarg)),
  306.                     firstarg, secondarg);
  307.             break;
  308.             
  309.         case 8:        /* block start */
  310.             /* first get previous link */
  311.             i = intValue(basicAt(processStack, linkPointer));
  312.             /* change context and byte pointer */
  313.             fieldAtPut(processStack, i+1, firstarg);
  314.             fieldAtPut(processStack, i+4, secondarg);
  315.             break;
  316.  
  317.         case 9:        /* duplicate a block, adding a new context to it */
  318.             returnedObject = newBlock();
  319.             basicAtPut(returnedObject, 1, secondarg);
  320.             basicAtPut(returnedObject, 2, basicAt(firstarg, 2));
  321.             basicAtPut(returnedObject, 3, basicAt(firstarg, 3));
  322.             basicAtPut(returnedObject, 4, basicAt(firstarg, 4));
  323.             break;
  324.  
  325.         default:        /* unknown primitive */
  326.             sysError("unknown primitive","binaryPrims");
  327.             break;
  328.  
  329.     }
  330.     return(returnedObject);
  331. }
  332.  
  333. static int trinaryPrims(int number, object firstarg, object secondarg, object thirdarg)
  334. {    char *bp, *tp, buffer[256];
  335.     int i, j;
  336.     object returnedObject;
  337.  
  338.     returnedObject = firstarg;
  339.     switch(number) {
  340.         case 1:            /* basicAt:Put: */
  341.             if (! isInteger(secondarg))
  342.                 sysError("non integer index","basicAtPut");
  343. fprintf(stderr,"IN BASICATPUT %d %d %d\n", firstarg, intValue(secondarg), thirdarg);
  344.             fieldAtPut(firstarg, intValue(secondarg), thirdarg);
  345.             break;
  346.  
  347.         case 2:            /* basicAt:Put: for bytes */
  348.             if (! isInteger(secondarg))
  349.                 sysError("non integer index","byteAtPut");
  350.             if (! isInteger(thirdarg))
  351.                 sysError("assigning non int","to byte");
  352.             byteAtPut(firstarg, intValue(secondarg),
  353.                     intValue(thirdarg));
  354.             break;
  355.  
  356.         case 3:            /* string copyFrom:to: */
  357.             bp = charPtr(firstarg);
  358.             if ((! isInteger(secondarg)) || (! isInteger(thirdarg)))
  359.                 sysError("non integer index","copyFromTo");
  360.             i = intValue(secondarg);
  361.             j = intValue(thirdarg);
  362.             tp = buffer;
  363.             if (i <= strlen(bp))
  364.                 for ( ; (i <= j) && bp[i-1]; i++)
  365.                     *tp++ = bp[i-1];
  366.             *tp = '\0';
  367.             returnedObject = newStString(buffer);
  368.             break;
  369.  
  370.         case 9:            /* compile method */
  371.             setInstanceVariables(firstarg);
  372.             if (parse(thirdarg, charPtr(secondarg), false)) {
  373.                 flushCache(basicAt(thirdarg, messageInMethod), firstarg);
  374.                 returnedObject = trueobj;
  375.                 }
  376.             else
  377.                 returnedObject = falseobj;
  378.             break;
  379.         
  380.         default:        /* unknown primitive */
  381.             sysError("unknown primitive","trinaryPrims");
  382.             break;
  383.         }
  384.     return(returnedObject);
  385. }
  386.  
  387. static int intUnary(int number, int firstarg)
  388. {    object returnedObject;
  389.     
  390.     switch(number) {
  391.         case 1:        /* float equiv of integer */
  392.             returnedObject = newFloat((double) firstarg);
  393.             break;
  394.  
  395.         case 2:        /* print - for debugging purposes */
  396.             fprintf(stderr,"debugging print %d\n", firstarg);
  397.             break;
  398.  
  399.         case 3: /* set time slice - done in interpreter */
  400.             break;
  401.  
  402.         case 5:        /* set random number */
  403.             ignore srand((unsigned) firstarg);
  404.             returnedObject = nilobj;
  405.             break;
  406.  
  407.         case 8:
  408.             returnedObject = allocObject(firstarg);
  409.             break;
  410.  
  411.         case 9:
  412.             returnedObject = allocByte(firstarg);
  413.             break;
  414.  
  415.         default:
  416.             sysError("intUnary primitive","not implemented yet");
  417.         }
  418.     return(returnedObject);
  419. }
  420.  
  421. static object intBinary(int number, int firstarg, int secondarg)
  422. {    boolean binresult;
  423.     long longresult;
  424.     object returnedObject;
  425.  
  426.     switch(number) {
  427.         case 0:        /* addition */
  428.             longresult = firstarg;
  429.             longresult += secondarg;
  430.             if (longCanBeInt(longresult))
  431.                 firstarg = longresult; 
  432.             else
  433.                 goto overflow;
  434.             break;
  435.         case 1:        /* subtraction */
  436.             longresult = firstarg;
  437.             longresult -= secondarg;
  438.             if (longCanBeInt(longresult))
  439.                 firstarg = longresult;
  440.             else
  441.                 goto overflow;
  442.             break;
  443.  
  444.         case 2:        /* relationals */
  445.             binresult = firstarg < secondarg; break;
  446.         case 3:
  447.             binresult = firstarg > secondarg; break;
  448.         case 4:
  449.             binresult = firstarg <= secondarg; break;
  450.         case 5:
  451.             binresult = firstarg >= secondarg; break;
  452.         case 6: case 13:
  453.             binresult = firstarg == secondarg; break;
  454.         case 7:
  455.             binresult = firstarg != secondarg; break;
  456.  
  457.         case 8:        /* multiplication */
  458.             longresult = firstarg;
  459.             longresult *= secondarg;
  460.             if (longCanBeInt(longresult))
  461.                 firstarg = longresult;
  462.             else
  463.                 goto overflow;
  464.             break;
  465.  
  466.         case 9:        /* quo: */
  467.             if (secondarg == 0) goto overflow;
  468.             firstarg /= secondarg; break;
  469.  
  470.         case 10:    /* rem: */
  471.             if (secondarg == 0) goto overflow;
  472.             firstarg %= secondarg; break;
  473.  
  474.         case 11:    /* bit operations */
  475.             firstarg &= secondarg; break;
  476.  
  477.         case 12:
  478.             firstarg ^= secondarg; break;
  479.             
  480.         case 19:    /* shifts */
  481.             if (secondarg < 0)
  482.                 firstarg >>= (- secondarg);
  483.             else
  484.                 firstarg <<= secondarg;
  485.             break;
  486.     }
  487.     if ((number >= 2) && (number <= 7))
  488.         if (binresult)
  489.             returnedObject = trueobj;
  490.         else
  491.             returnedObject = falseobj;
  492.     else
  493.         returnedObject = newInteger(firstarg);
  494.     return(returnedObject);
  495.  
  496.         /* on overflow, return nil and let smalltalk code */
  497.         /* figure out what to do */
  498. overflow:
  499.     returnedObject = nilobj;
  500.     return(returnedObject);
  501. }
  502.  
  503. static int strUnary(int number, char *firstargument)
  504. {    object returnedObject;
  505.  
  506.     switch(number) {
  507.         case 1:        /* length of string */
  508.             returnedObject = newInteger(strlen(firstargument));
  509.             break;
  510.  
  511.         case 2:     /* hash value of symbol */
  512.             returnedObject = newInteger(strHash(firstargument));
  513.             break;
  514.  
  515.         case 3:        /* string as symbol */
  516.             returnedObject = newSymbol(firstargument);
  517.             break;
  518.  
  519.         case 7:        /* value of symbol */
  520.             returnedObject = globalSymbol(firstargument);
  521.             break;
  522.  
  523.         case 8:
  524. # ifndef NOSYSTEM
  525.             returnedObject = newInteger(system(firstargument));
  526. # endif
  527.             break;
  528.  
  529.         case 9:
  530.             sysError("fatal error", firstargument);
  531.             break;
  532.  
  533.         default:
  534.             sysError("unknown primitive", "strUnary");
  535.             break;
  536.         }
  537.  
  538.     return(returnedObject);
  539. }
  540.  
  541. static int floatUnary(int number, double firstarg)
  542. {    char buffer[20];
  543.     double temp;
  544.     int i, j;
  545.     object returnedObject;
  546.  
  547.     switch(number) {
  548.         case 1:        /* floating value asString */
  549.             ignore sprintf(buffer,"%g", firstarg);
  550.             returnedObject = newStString(buffer);
  551.             break;
  552.  
  553.         case 2:        /* log */
  554.             returnedObject = newFloat(log(firstarg));
  555.             break;
  556.  
  557.         case 3:        /* exp */
  558.             returnedObject = newFloat(exp(firstarg));
  559.             break;
  560.  
  561.         case 6:        /* integer part */
  562.                 /* return two integers n and m such that */
  563.                 /* number can be written as n * 2** m */
  564. # define ndif 12
  565.             temp = frexp(firstarg, &i);
  566.             if ((i >= 0)&&(i <= ndif)) {temp=ldexp(temp, i); i=0;}
  567.             else { i -= ndif; temp = ldexp(temp, ndif); }
  568.             j = (int) temp;
  569.             returnedObject = newArray(2);
  570.             basicAtPut(returnedObject, 1, newInteger(j));
  571.             basicAtPut(returnedObject, 2, newInteger(i));
  572. # ifdef trynew
  573.             /* if number is too big it can't be integer anyway */
  574.             if (firstarg > 2e9)
  575.                 returnedObject = nilobj;
  576.             else {
  577.                 ignore modf(firstarg, &temp);
  578.                 ltemp = (long) temp;
  579.                 if (longCanBeInt(ltemp))
  580.                     returnedObject = newInteger((int) temp);
  581.                 else
  582.                     returnedObject = newFloat(temp);
  583.                 }
  584. # endif
  585.             break;
  586.  
  587.         default:
  588.             sysError("unknown primitive","floatUnary");
  589.             break;
  590.         }
  591.  
  592.     return(returnedObject);
  593. }
  594.  
  595. static object floatBinary(int number, double first, double second)
  596. {     boolean binResult;
  597.     object returnedObject;
  598.  
  599.     switch(number) {
  600.         case 0: first += second; break;
  601.  
  602.         case 1:    first -= second; break;
  603.         case 2: binResult = (first < second); break;
  604.         case 3: binResult = (first > second); break;
  605.         case 4: binResult = (first <= second); break;
  606.         case 5: binResult = (first >= second); break;
  607.         case 6: binResult = (first == second); break;
  608.         case 7: binResult = (first != second); break;
  609.         case 8: first *= second; break;
  610.         case 9: first /= second; break;
  611.         default:    
  612.             sysError("unknown primitive", "floatBinary");
  613.             break;
  614.         }
  615.  
  616.     if ((number >= 2) && (number <= 7))
  617.         if (binResult)
  618.             returnedObject = trueobj;
  619.         else
  620.             returnedObject = falseobj;
  621.     else
  622.         returnedObject = newFloat(first);
  623.     return(returnedObject);
  624. }
  625.  
  626. /* primitive -
  627.     the main driver for the primitive handler
  628. */
  629. object primitive(int primitiveNumber, object *arguments)
  630. {    register int primitiveGroup = primitiveNumber / 10;
  631.     object returnedObject;
  632.  
  633.  
  634.     if (primitiveNumber >= 150) {
  635.         /* system dependent primitives, handled in separate module */
  636.         returnedObject = sysPrimitive(primitiveNumber, arguments);
  637.         }
  638.     else {
  639.         switch(primitiveGroup) {
  640.         case 0:
  641.             returnedObject = zeroaryPrims(primitiveNumber);
  642.             break;
  643.         case 1:
  644.             returnedObject = unaryPrims(primitiveNumber - 10, arguments[0]);
  645.             break;
  646.         case 2:
  647.             returnedObject = binaryPrims(primitiveNumber-20, arguments[0], arguments[1]);
  648.             break;
  649.         case 3:
  650.             returnedObject = trinaryPrims(primitiveNumber-30, arguments[0], arguments[1], arguments[2]);
  651.             break;
  652.  
  653.         case 5:            /* integer unary operations */
  654.             if (! isInteger(arguments[0]))
  655.                 returnedObject = nilobj;
  656.             else
  657.                 returnedObject = intUnary(primitiveNumber-50,
  658.                         intValue(arguments[0]));
  659.             break;
  660.  
  661.         case 6: case 7:        /* integer binary operations */
  662.             if ((! isInteger(arguments[0])) || 
  663.                   ! isInteger(arguments[1]))
  664.                 returnedObject = nilobj;
  665.             else
  666.                 returnedObject = intBinary(primitiveNumber-60,
  667.                     intValue(arguments[0]), 
  668.                     intValue(arguments[1]));
  669.             break;
  670.  
  671.         case 8:            /* string unary */
  672.             returnedObject = strUnary(primitiveNumber-80, charPtr(arguments[0]));
  673.             break;
  674.  
  675.         case 10:        /* float unary */
  676.             returnedObject = floatUnary(primitiveNumber-100, floatValue(arguments[0]));
  677.             break;
  678.  
  679.         case 11:        /* float binary */
  680.             returnedObject = floatBinary(primitiveNumber-110,
  681.                     floatValue(arguments[0]),
  682.                     floatValue(arguments[1]));
  683.             break;
  684.  
  685.         case 12: case 13:    /* file operations */
  686.  
  687.             returnedObject = ioPrimitive(primitiveNumber-120, arguments);
  688.             break;
  689.  
  690.             
  691.         default:
  692.             sysError("unknown primitive number","doPrimitive");
  693.             break;
  694.         }
  695.     }
  696.  
  697.     return (returnedObject);
  698. }
  699.  
  700.